(define-imported-class (text-writer "System.IO.TextWriter") object)

(define text-reader (type-expression-value 'text-reader))
(import-methods (last-index-of "LastIndexOf"
			       (proc (string character) integer))
		(write-char "Write"
			    (proc ((type-expression-value 'text-writer)
				   character)
				  void))
		(first-index-of "IndexOf"
				(proc (string character) integer))
		(stream-close "Close" (proc (text-reader) void))
		(substring "Substring"
			   (proc (string integer integer) string)))

(import-static (get-unicode-category "Char.GetUnicodeCategory"
				     (proc (character) integer))
	       (string->single-float "Single.Parse"
				     (proc (string) single-float))
	       (cons "Lists.Cons"
		     (proc (object object) object))
	       (string=? "0==String.Compare" (proc (string string boolean) boolean)))

(define-imported-class (fluid (object default-value)) Procedure
  (define fluid-value "Value" (public) object))
(define-imported-class (file-fluid (object default-value)) fluid)
(define-imported-class (package-fluid (object default-value)) fluid)

(define-imported-class reader object)

(%import-object 'void-object "" void-type)
(%import-object 'initial-quote-punctuation "System.Globalization.UnicodeCategory.InitialQuotePunctuation"
	 integer-type)
(%import-object 'final-quote-punctuation "System.Globalization.UnicodeCategory.FinalQuotePunctuation"
	 integer-type)
(%import-object 'open-punctuation "System.Globalization.UnicodeCategory.OpenPunctuation"
	 integer-type)
(%import-object 'close-punctuation "System.Globalization.UnicodeCategory.ClosePunctuation"
	 integer-type)
(%import-object 'current-reader-kluge
		"((Reader)Reader.currentReader.Value)"
		(type-expression-value 'reader))

(define-imported-class (syntax-error (string message)
				     (object offending-expression))
  object)

(define-imported-class (lexical-syntax-error (string message)
					     (object offending-expression))
  object)

(define-imported-class (parse-error (string message)
				    (object offending-expression))
  object)

(define-imported-class (numeric-syntax-error (string message)
					     (object offending-expression))
  lexical-syntax-error)
(define-imported-class (incomplete-expression-error (string message)
						    (object offending-expression))
  lexical-syntax-error)
(define-imported-class (extra-bracket-error (string message)
					    (object offending-expression))
  lexical-syntax-error)
(define-imported-class (missing-body-error (string message)
					   (object offending-expression))
  parse-error)

(define-imported-class (stack "System.Collections.Stack") array-list
  (define (stack-push "Push" (object o)) (public) void)
  (define (stack-pop "Pop") (public) object))


(define-module (lisp reader)
  (define-class (reader str file-position) object
    (define reader-stack (public static fluid)
      (new fluid (new stack)))
    ;;
    ;; STREAM STUFF
    ;;
    (define str "baseTextReader" (private text-reader) null)
    (define transcript (public text-writer) null)

    (define (close this) (public void)
      (stream-close (str this)))

;    ;; We do our own look-ahead buffering rather than using peek
;    ;; because peek has strange behavior with standard-input.
;    (define current-char (private character) #\space)

    (define file-position (public integer) 0)
    (define list-position-table (private hashtable)
      (hashtable))

    (define (list-position list) (public static integer)
      (let ((r (as current-reader-kluge
		   reader)))
	(when (null? r)
	  (return -1))
	(let ((probe (gethash (list-position-table r)
			      list)))
	  (if (null? probe)
	      -1
	      (cast integer probe)))))

    (define (declare-source r new-list old-list) "DeclareSourceAlias"
      (public void)
      (unless (null? old-list)
	(let ((probe (gethash (list-position-table r)
			      old-list)))
	  (unless (null? probe)
	    (set (gethash (list-position-table r)
			  new-list)
		 probe)))))

    (define comment-start-char (private static character)
      (cast character #xab))
    (define comment-end-char (private static character)
      (cast character #xbb))

    (define current-reader-fluid "currentReader" (public static fluid)
      (fluid null))

    (define (peek-char r) (private integer)
;      current-char)
      (peek (str r)))

    (define eof-character (private static integer)
      -1)

    (define (check-eof (integer ch)) (private static integer)
      (when (eq? ch eof-character)
	;; End of File!
	(throw (new incomplete-expression-error
		    "Expression ended prematurely"
		    null)))
      ch)

    (define (next-char r) (private integer)
      (let ((ch (read (str r))))
	(check-eof ch)
	(unless (null? (transcript r))
	  (write-char (transcript r)
		      (cast character ch)))
	(set (file-position r)
	     (+ (file-position r)
		1))
	ch))
;	;; Keep going
;	(set current-char (cast character (read (str r))))
;	old))

    ;;
    ;; USEFUL SUBROUTINES
    ;;
    (define (array-list->string (array-list chars)) (public static string)
      (let ((arr (new-array character (count chars))))
	(copy-to chars arr 0)
	(array->string arr)))

    ;;
    ;; CHARACTER CLASSES
    ;;
    (define (delimiter? (character c)) (private static boolean)
      (or (whitespace? c)
	  (= (get-unicode-category c)
	     open-punctuation)
	  (= (get-unicode-category c)
	     close-punctuation)))

    (define (greyspace? (character c)) (private static boolean)
      (or (whitespace? c)
	  (= (cast integer c)
	     #xffff)))

    (define (swallow-whitespace r) (public void)
      (while (whitespace? (cast character (peek-char r)))
	(next-char r)))

    (define (swallow-whitespace-and-comments r) (public void)
      (swallow-whitespace r)
      (let ((next (cast character (peek-char r))))
	(while #t
	  (cond ((eq? next comment-start-char)
		 (start-comment r)
		 (next-char r)
		 (swallow-multiline-comment r)
		 (end-comment r))
		((eq? next #\;)
		 (start-comment r)
		 (swallow-single-line-comment r)
		 (end-comment r))
		(else
		 (return void-object)))
	  (swallow-whitespace r)
	  (set next (cast character (peek-char r))))))

    ;; Swallow a << >> comment, including recursive comments
    ;; Entry: << has been swallowed
    ;; Exit: >> has been swallowed
    (define (swallow-multiline-comment r) (public void)
      (let ((next (cast character (next-char r))))
	(while (not (eq? next comment-end-char))
	  (when (eq? next comment-start-char)
	    ;; Recursive comment
	    (swallow-multiline-comment r))
	  (set next (cast character (next-char r))))))

    (define (swallow-single-line-comment r) (public void)
      (let ((ch (cast character (peek-char r))))
	(while (not (or (eq? ch #\newline)
			(eq? ch (cast character eof-character))))
	  (next-char r)
	  (set ch (cast character (peek-char r))))))

    (define (start-comment r) (public virtual void)
      #f)
    (define (end-comment r) (public virtual void)
      #f)

    (define (is-at-eof r) (public boolean)
      (eq? (peek (str r))
	   eof-character))

    ;;
    ;; READING TOKENS
    ;;
    (define (read-token r) (public string)
      (swallow-whitespace-and-comments r)
      (let ((chars (array-list))
	    (rstack (cast stack
			  (fluid-value reader-stack))))
	(stack-push rstack chars)
	(while (not (delimiter? (cast character (peek-char r))))
	  (add chars (cast character (next-char r))))
	(stack-pop rstack)
	(when (= (count chars) 0)
	  (throw (lexical-syntax-error "Empty token (probably a bug in the parser)"
			       null)))
	(array-list->string chars)))

    ;;
    ;; DECODING TOKENS
    ;;
    (define (read-number r) (private object)
      (let ((t (read-token r)))
	(let ((first-char (string-ref t 0))
	      (decimal-points 0)
	      (badchars? #f)
	      (single-float? #f))
	  (when (eq? first-char (cast character #x2212))
	    (set first-char #\-))
	  (cond ((= (length t) 1)
		 (if (digit? first-char)
		     (string->integer t)
		     (parse-token t)))
		(else
		 (unless (or (digit? first-char)
			     (eq? first-char #\.)
			     (eq? first-char #\+)
			     (eq? first-char #\-))
		   (set badchars? #t))
		 (if (eq? first-char #\.)
		     (set decimal-points 1))
		 (for ((i 1 (+ 1 i)))
		      (< i (length t))
		   (let ((ch (string-ref t i)))
	            (cond ((eq? ch #\.)
			   (inc decimal-points))
			  ((and (or (eq? ch #\F)
				    (eq? ch #\f))
				(= i (- (length t) 1)))
			   (set single-float? #t))
			  ((not (digit? ch))
			   (set badchars? #t)))))
		 (cond ((or badchars? (> decimal-points 1))
			(parse-token t))
		       (single-float?
			(string->single-float (substring t 0 (- (length t) 1))))
		       ((> decimal-points 0)
			(string->float t))
		       (else
			(string->integer t))))))))

    (define (read-symbol r) (private object)
      (let ((starting-position (file-position r))
	    (t (read-token r)))
	(got-symbol r t)
	(cond ((string=? t "true" #t)
	       #t)
	      ((string=? t "false" #t)
	       #f)
	      ((string=? t "null" #t)
	       null)
	      (else
	       (let ((result (parse-token t)))
		 (when (is? result (array object))
		   (set (gethash (list-position-table r)
				 result)
			starting-position))
		 result)))))

    (define (got-symbol r (string token)) (public virtual void)
      #f)

    (define (digit-string? s) (private static boolean)
      (dotimes (i (length s))
	(if (not (digit? (string-ref s i)))
	    (return #f)))
      #t)

    (define (parse-token (string tok)) (private static object)
      (let ((point (last-index-of tok #\.)))
	(cond ((eq? tok "...")
	       (intern tok))
	      ((= point 0)
	       (stack-push (cast stack
			   (fluid-value reader-stack))
		     tok)
	       (throw (lexical-syntax-error "Can't begin a token with '.'"
					    tok)))
	      ((= point
		  (- (length tok)
		     1))
	       (stack-push (cast stack
			   (fluid-value reader-stack))
		     tok)
	       (throw (lexical-syntax-error "Can't end a token with '.'"
					    tok)))
	      ((> point 0)
	       (let ((left-side (substring tok 0 point))
		     (right-side (substring tok
					    (+ point 1)
					    (- (length tok)
					       (+ point 1)))))
		 (when (or (digit-string? left-side)
			   (digit-string? right-side))
		   (stack-push (cast stack
			       (fluid-value reader-stack))
			 tok)
		   (throw (numeric-syntax-error "This looks like a number with a typo"
						tok)))
		 (new-array object 3
			    s-member
			    (parse-token left-side)
			    right-side)))
	      (else
	       (intern tok)))))

    (define (string-quote? (character c)) (public static boolean)
      (or (eq? c (cast character #x201c)) ; left dquote
	  (eq? c (cast character #x201d)) ; right dquote
	  (eq? c #\")))                   ; unoriented dquote

    (define (read-string r) (private string)
      (next-char r)
      (let ((chars (array-list))
	    (rstack (cast stack
			  (fluid-value reader-stack))))
	(stack-push rstack chars)
	(while (not (string-quote? (cast character (peek-char r))))
	  (let ((ch (cast character (next-char r))))
	    (when (eq? ch #\\)
	      (let ((next (cast character (next-char r))))
		(cond ((eq? next #\r)
		       (set ch (cast character 13)))
		      ((eq? next #\n)
		       (set ch (cast character 10)))
		      ((eq? next #\t)
		       (set ch (cast character 9)))
		      (else
		       (set ch next)))))
	    (add chars ch)))
	(stack-pop rstack)
	(next-char r)
	(array-list->string chars)))

    (define (read-quote r (symbol op-symbol)) (private object)
      (let ((starting-position (- (file-position r)
				  (if (eq? op-symbol s-unquote-splicing)
				      2
				      1)))
	    (list (new-array object 2 op-symbol (read-object r))))
	(set (gethash (list-position-table r)
		      list)
	     starting-position)
	list))

    ;;
    ;; READING LISTS (really arrays)
    ;;
    (define (read-list r) (private object)
      (let ((elts (array-list))
	    (rstack (cast stack
			  (fluid-value reader-stack))))
	(stack-push rstack elts)
	(swallow-whitespace-and-comments r)
	(let ((starting-position (file-position r)))
	  (start-list r)
	  (next-char r)			;swallow bracket
	  (swallow-whitespace-and-comments r)
	  (while (not (or (eq? (get-unicode-category (cast character (peek-char r)))
			       close-punctuation)
			  (eq? (cast character (peek-char r))
			       #\})))
	    (start-element r)
	    (add elts (read-object r))
	    (end-element r elts)
	    (swallow-whitespace-and-comments r))
	  (end-list r)
	  (next-char r)			;swallow bracket
	  (let ((retval (to-array elts)))
	    (set (gethash (list-position-table r)
			  retval)
		 starting-position)
	    (cond ((eq? (cast character (peek-char r))
			#\.)
		   (next-char r)	;swallow .
		   (let ((tok (read-token r))
			 (point (first-index-of tok #\.)))
		     (while (>= point 0)
		       (set retval
			    (new-array object 3
				       s-member
				       retval
				       (substring tok 0 point)))
		       (set (gethash (list-position-table r)
				     retval)
			    starting-position)
		       (set tok (substring tok
					   (+ point 1)
					   (- (length tok)
					      (+ point 1))))
		       (set point (first-index-of tok #\.)))
		     (set retval
			  (new-array object 3 s-member retval tok)))))
	    (stack-pop rstack)
	    retval))))

    ;; Called at open bracket of list
    (define (start-list r) (public virtual void)
      #f)
    ;; Called at close bracket
    (define (end-list r) (public virtual void)
      #f)

    ;; Called at first non-whitespace char of element
    (define (start-element r) (public virtual void)
      #f)
    ;; Called after last char of element
    (define (end-element r (array-list l)) (public virtual void)
      #f)

    ;;
    ;; READING GENERALIZED LISTS (generalized arrays)
    ;;
    (define (read-object r) "Read" (public object)
      (swallow-whitespace-and-comments r)
      (let ((first-char (cast character (peek-char r))))
	(when (eq? first-char (cast character eof-character))
	  (throw (incomplete-expression-error "Incomplete expression (text ends before end of expression)" null)))
	(when (eq? first-char #\])
	  (throw (extra-bracket-error "Extra ] in expression" null)))
	(cond ((eq? first-char #\{)
	       (let ((start (file-position r))
		     (list (cons lambda-arrow (cast ilist (read-list r)))))
		 (set (gethash (list-position-table r)
			       list)
		      start)
		 list))
	      ((eq? (get-unicode-category first-char)
		    open-punctuation)
	       (read-list r))
	      ((eq? first-char #\')
	       (next-char r)
	       (read-quote r s-quote))
	      ((eq? first-char #\`)
	       (next-char r)
	       (read-quote r s-quasiquote))
	      ((eq? first-char #\,)
	       (next-char r)
	       (cond ((eq? (peek-char r) #\@)
		      (next-char r)
		      (read-quote r s-unquote-splicing))
		     (else
		      (read-quote r s-unquote))))
	      ((or (digit? first-char)
		   (eq? first-char #\.)
		   (eq? first-char #\+)
		   (eq? first-char (cast character #x2212))
		   (eq? first-char #\-))
	       (read-number r))
	      ((string-quote? first-char)
	       (read-string r))
	      (else
	       (read-symbol r)))))))